home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol146 / xlmath.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-12-16  |  10.5 KB  |  517 lines
  1. /* xlmath - xlisp builtin arithmetic functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include <math.h>
  7. #include "xlisp.h"
  8.  
  9. #ifdef MEGAMAX
  10. overlay "math"
  11. #endif
  12.  
  13. /* external variables */
  14. extern NODE *xlstack;
  15. extern NODE *true;
  16.  
  17. /* forward declarations */
  18. FORWARD NODE *unary();
  19. FORWARD NODE *binary();
  20. FORWARD NODE *predicate();
  21. FORWARD NODE *compare();
  22.  
  23. /* xadd - builtin function for addition */
  24. NODE *xadd(args)
  25.   NODE *args;
  26. {
  27.     return (binary(args,'+'));
  28. }
  29.  
  30. /* xsub - builtin function for subtraction */
  31. NODE *xsub(args)
  32.   NODE *args;
  33. {
  34.     return (binary(args,'-'));
  35. }
  36.  
  37. /* xmul - builtin function for multiplication */
  38. NODE *xmul(args)
  39.   NODE *args;
  40. {
  41.     return (binary(args,'*'));
  42. }
  43.  
  44. /* xdiv - builtin function for division */
  45. NODE *xdiv(args)
  46.   NODE *args;
  47. {
  48.     return (binary(args,'/'));
  49. }
  50.  
  51. /* xrem - builtin function for remainder */
  52. NODE *xrem(args)
  53.   NODE *args;
  54. {
  55.     return (binary(args,'%'));
  56. }
  57.  
  58. /* xmin - builtin function for minimum */
  59. NODE *xmin(args)
  60.   NODE *args;
  61. {
  62.     return (binary(args,'m'));
  63. }
  64.  
  65. /* xmax - builtin function for maximum */
  66. NODE *xmax(args)
  67.   NODE *args;
  68. {
  69.     return (binary(args,'M'));
  70. }
  71.  
  72. /* xexpt - built-in function 'expt' */
  73. NODE *xexpt(args)
  74.   NODE *args;
  75. {
  76.     return (binary(args,'E'));
  77. }
  78.  
  79. /* xbitand - builtin function for bitwise and */
  80. NODE *xbitand(args)
  81.   NODE *args;
  82. {
  83.     return (binary(args,'&'));
  84. }
  85.  
  86. /* xbitior - builtin function for bitwise inclusive or */
  87. NODE *xbitior(args)
  88.   NODE *args;
  89. {
  90.     return (binary(args,'|'));
  91. }
  92.  
  93. /* xbitxor - builtin function for bitwise exclusive or */
  94. NODE *xbitxor(args)
  95.   NODE *args;
  96. {
  97.     return (binary(args,'^'));
  98. }
  99.  
  100. /* binary - handle binary operations */
  101. LOCAL NODE *binary(args,fcn)
  102.   NODE *args; int fcn;
  103. {
  104.     FIXNUM ival,iarg;
  105.     FLONUM fval,farg;
  106.     NODE *arg;
  107.     int imode;
  108.  
  109.     /* get the first argument */
  110.     arg = xlarg(&args);
  111.  
  112.     /* set the type of the first argument */
  113.     if (fixp(arg)) {
  114.     ival = arg->n_int;
  115.     imode = TRUE;
  116.     }
  117.     else if (floatp(arg)) {
  118.     fval = arg->n_float;
  119.     imode = FALSE;
  120.     }
  121.     else
  122.     xlerror("bad argument type",arg);
  123.  
  124.     /* treat '-' with a single argument as a special case */
  125.     if (fcn == '-' && args == NIL)
  126.     if (imode)
  127.         ival = -ival;
  128.     else
  129.         fval = -fval;
  130.  
  131.     /* handle each remaining argument */
  132.     while (args) {
  133.  
  134.     /* get the next argument */
  135.     arg = xlarg(&args);
  136.  
  137.     /* check its type */
  138.     if (fixp(arg))
  139.         if (imode) iarg = arg->n_int;
  140.         else farg = (FLONUM)arg->n_int;
  141.     else if (floatp(arg))
  142.         if (imode) { fval = (FLONUM)ival; farg = arg->n_float; imode = FALSE; }
  143.         else farg = arg->n_float;
  144.     else
  145.         xlerror("bad argument type",arg);
  146.  
  147.     /* accumulate the result value */
  148.     if (imode)
  149.         switch (fcn) {
  150.         case '+':    ival += iarg; break;
  151.         case '-':    ival -= iarg; break;
  152.         case '*':    ival *= iarg; break;
  153.         case '/':    checkizero(iarg); ival /= iarg; break;
  154.         case '%':    checkizero(iarg); ival %= iarg; break;
  155.         case 'M':    if (iarg > ival) ival = iarg; break;
  156.         case 'm':    if (iarg < ival) ival = iarg; break;
  157.         case '&':    ival &= iarg; break;
  158.         case '|':    ival |= iarg; break;
  159.         case '^':    ival ^= iarg; break;
  160.         default:    badiop();
  161.         }
  162.     else
  163.         switch (fcn) {
  164.         case '+':    fval += farg; break;
  165.         case '-':    fval -= farg; break;
  166.         case '*':    fval *= farg; break;
  167.         case '/':    checkfzero(farg); fval /= farg; break;
  168.         case 'M':    if (farg > fval) fval = farg; break;
  169.         case 'm':    if (farg < fval) fval = farg; break;
  170.         case 'E':    fval = pow(fval,farg); break;
  171.         default:    badfop();
  172.         }
  173.     }
  174.  
  175.     /* return the result */
  176.     return (imode ? cvfixnum(ival) : cvflonum(fval));
  177. }
  178.  
  179. /* checkizero - check for integer division by zero */
  180. checkizero(iarg)
  181.   FIXNUM iarg;
  182. {
  183.     if (iarg == 0)
  184.     xlfail("division by zero");
  185. }
  186.  
  187. /* checkfzero - check for floating point division by zero */
  188. checkfzero(farg)
  189.   FLONUM farg;
  190. {
  191.     if (farg == 0.0)
  192.     xlfail("division by zero");
  193. }
  194.  
  195. /* checkfneg - check for square root of a negative number */
  196. checkfneg(farg)
  197.   FLONUM farg;
  198. {
  199.     if (farg < 0.0)
  200.     xlfail("square root of a negative number");
  201. }
  202.  
  203. /* xbitnot - bitwise not */
  204. NODE *xbitnot(args)
  205.   NODE *args;
  206. {
  207.     return (unary(args,'~'));
  208. }
  209.  
  210. /* xabs - builtin function for absolute value */
  211. NODE *xabs(args)
  212.   NODE *args;
  213. {
  214.     return (unary(args,'A'));
  215. }
  216.  
  217. /* xadd1 - builtin function for adding one */
  218. NODE *xadd1(args)
  219.   NODE *args;
  220. {
  221.     return (unary(args,'+'));
  222. }
  223.  
  224. /* xsub1 - builtin function for subtracting one */
  225. NODE *xsub1(args)
  226.   NODE *args;
  227. {
  228.     return (unary(args,'-'));
  229. }
  230.  
  231. /* xsin - built-in function 'sin' */
  232. NODE *xsin(args)
  233.   NODE *args;
  234. {
  235.     return (unary(args,'S'));
  236. }
  237.  
  238. /* xcos - built-in function 'cos' */
  239. NODE *xcos(args)
  240.   NODE *args;
  241. {
  242.     return (unary(args,'C'));
  243. }
  244.  
  245. /* xtan - built-in function 'tan' */
  246. NODE *xtan(args)
  247.   NODE *args;
  248. {
  249.     return (unary(args,'T'));
  250. }
  251.  
  252. /* xexp - built-in function 'exp' */
  253. NODE *xexp(args)
  254.   NODE *args;
  255. {
  256.     return (unary(args,'E'));
  257. }
  258.  
  259. /* xsqrt - built-in function 'sqrt' */
  260. NODE *xsqrt(args)
  261.   NODE *args;
  262. {
  263.     return (unary(args,'R'));
  264. }
  265.  
  266. /* xfix - built-in function 'fix' */
  267. NODE *xfix(args)
  268.   NODE *args;
  269. {
  270.     return (unary(args,'I'));
  271. }
  272.  
  273. /* xfloat - built-in function 'float' */
  274. NODE *xfloat(args)
  275.   NODE *args;
  276. {
  277.     return (unary(args,'F'));
  278. }
  279.  
  280. /* unary - handle unary operations */
  281. LOCAL NODE *unary(args,fcn)
  282.   NODE *args; int fcn;
  283. {
  284.     FLONUM fval;
  285.     FIXNUM ival;
  286.     NODE *arg;
  287.  
  288.     /* get the argument */
  289.     arg = xlarg(&args);
  290.     xllastarg(args);
  291.  
  292.     /* check its type */
  293.     if (fixp(arg)) {
  294.     ival = arg->n_int;
  295.     switch (fcn) {
  296.     case '~':    ival = ~ival; break;
  297.     case 'A':    ival = abs(ival); break;
  298.     case '+':    ival++; break;
  299.     case '-':    ival--; break;
  300.     case 'I':    break;
  301.     case 'F':    return (cvflonum((FLONUM)ival));
  302.     default:    badiop();
  303.     }
  304.     return (cvfixnum(ival));
  305.     }
  306.     else if (floatp(arg)) {
  307.     fval = arg->n_float;
  308.     switch (fcn) {
  309.     case 'A':    fval = fabs(fval); break;
  310.     case '+':    fval += 1.0; break;
  311.     case '-':    fval -= 1.0; break;
  312.     case 'S':    fval = sin(fval); break;
  313.     case 'C':    fval = cos(fval); break;
  314.     case 'T':    fval = tan(fval); break;
  315.     case 'E':    fval = exp(fval); break;
  316.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  317.     case 'I':    return (cvfixnum((FIXNUM)fval));
  318.     case 'F':    break;
  319.     default:    badfop();
  320.     }
  321.     return (cvflonum(fval));
  322.     }
  323.     else
  324.     xlerror("bad argument type",arg);
  325. }
  326.  
  327. /* xminusp - is this number negative? */
  328. NODE *xminusp(args)
  329.   NODE *args;
  330. {
  331.     return (predicate(args,'-'));
  332. }
  333.  
  334. /* xzerop - is this number zero? */
  335. NODE *xzerop(args)
  336.   NODE *args;
  337. {
  338.     return (predicate(args,'Z'));
  339. }
  340.  
  341. /* xplusp - is this number positive? */
  342. NODE *xplusp(args)
  343.   NODE *args;
  344. {
  345.     return (predicate(args,'+'));
  346. }
  347.  
  348. /* xevenp - is this number even? */
  349. NODE *xevenp(args)
  350.   NODE *args;
  351. {
  352.     return (predicate(args,'E'));
  353. }
  354.  
  355. /* xoddp - is this number odd? */
  356. NODE *xoddp(args)
  357.   NODE *args;
  358. {
  359.     return (predicate(args,'O'));
  360. }
  361.  
  362. /* predicate - handle a predicate function */
  363. LOCAL NODE *predicate(args,fcn)
  364.   NODE *args; int fcn;
  365. {
  366.     FLONUM fval;
  367.     FIXNUM ival;
  368.     NODE *arg;
  369.  
  370.     /* get the argument */
  371.     arg = xlarg(&args);
  372.     xllastarg(args);
  373.  
  374.     /* check the argument type */
  375.     if (fixp(arg)) {
  376.     ival = arg->n_int;
  377.     switch (fcn) {
  378.     case '-':    ival = (ival < 0); break;
  379.     case 'Z':    ival = (ival == 0); break;
  380.     case '+':    ival = (ival > 0); break;
  381.     case 'E':    ival = ((ival & 1) == 0); break;
  382.     case 'O':    ival = ((ival & 1) != 0); break;
  383.     default:    badiop();
  384.     }
  385.     }
  386.     else if (floatp(arg)) {
  387.     fval = arg->n_float;
  388.     switch (fcn) {
  389.     case '-':    ival = (fval < 0); break;
  390.     case 'Z':    ival = (fval == 0); break;
  391.     case '+':    ival = (fval > 0); break;
  392.     default:    badfop();
  393.     }
  394.     }
  395.     else
  396.     xlerror("bad argument type",arg);
  397.  
  398.     /* return the result value */
  399.     return (ival ? true : NIL);
  400. }
  401.  
  402. /* xlss - builtin function for < */
  403. NODE *xlss(args)
  404.   NODE *args;
  405. {
  406.     return (compare(args,'<'));
  407. }
  408.  
  409. /* xleq - builtin function for <= */
  410. NODE *xleq(args)
  411.   NODE *args;
  412. {
  413.     return (compare(args,'L'));
  414. }
  415.  
  416. /* equ - builtin function for = */
  417. NODE *xequ(args)
  418.   NODE *args;
  419. {
  420.     return (compare(args,'='));
  421. }
  422.  
  423. /* xneq - builtin function for /= */
  424. NODE *xneq(args)
  425.   NODE *args;
  426. {
  427.     return (compare(args,'#'));
  428. }
  429.  
  430. /* xgeq - builtin function for >= */
  431. NODE *xgeq(args)
  432.   NODE *args;
  433. {
  434.     return (compare(args,'G'));
  435. }
  436.  
  437. /* xgtr - builtin function for > */
  438. NODE *xgtr(args)
  439.   NODE *args;
  440. {
  441.     return (compare(args,'>'));
  442. }
  443.  
  444. /* compare - common compare function */
  445. LOCAL NODE *compare(args,fcn)
  446.   NODE *args; int fcn;
  447. {
  448.     NODE *arg1,*arg2;
  449.     FIXNUM icmp;
  450.     FLONUM fcmp;
  451.     int imode;
  452.  
  453.     /* get the two arguments */
  454.     arg1 = xlarg(&args);
  455.     arg2 = xlarg(&args);
  456.     xllastarg(args);
  457.  
  458.     /* do the compare */
  459.     if (stringp(arg1) && stringp(arg2)) {
  460.     icmp = strcmp(arg1->n_str,arg2->n_str);
  461.     imode = TRUE;
  462.     }
  463.     else if (fixp(arg1) && fixp(arg2)) {
  464.     icmp = arg1->n_int - arg2->n_int;
  465.     imode = TRUE;
  466.     }
  467.     else if (floatp(arg1) && floatp(arg2)) {
  468.     fcmp = arg1->n_float - arg2->n_float;
  469.     imode = FALSE;
  470.     }
  471.     else if (fixp(arg1) && floatp(arg2)) {
  472.     fcmp = (FLONUM)arg1->n_int - arg2->n_float;
  473.     imode = FALSE;
  474.     }
  475.     else if (floatp(arg1) && fixp(arg2)) {
  476.     fcmp = arg1->n_float - (FLONUM)arg2->n_int;
  477.     imode = FALSE;
  478.     }
  479.     else
  480.     xlfail("expecting strings, integers or floats");
  481.  
  482.     /* compute result of the compare */
  483.     if (imode)
  484.     switch (fcn) {
  485.     case '<':    icmp = (icmp < 0); break;
  486.     case 'L':    icmp = (icmp <= 0); break;
  487.     case '=':    icmp = (icmp == 0); break;
  488.     case '#':    icmp = (icmp != 0); break;
  489.     case 'G':    icmp = (icmp >= 0); break;
  490.     case '>':    icmp = (icmp > 0); break;
  491.     }
  492.     else
  493.     switch (fcn) {
  494.     case '<':    icmp = (fcmp < 0.0); break;
  495.     case 'L':    icmp = (fcmp <= 0.0); break;
  496.     case '=':    icmp = (fcmp == 0.0); break;
  497.     case '#':    icmp = (fcmp != 0.0); break;
  498.     case 'G':    icmp = (fcmp >= 0.0); break;
  499.     case '>':    icmp = (fcmp > 0.0); break;
  500.     }
  501.  
  502.     /* return the result */
  503.     return (icmp ? true : NIL);
  504. }
  505.  
  506. /* badiop - bad integer operation */
  507. LOCAL badiop()
  508. {
  509.     xlfail("bad integer operation");
  510. }
  511.  
  512. /* badfop - bad floating point operation */
  513. LOCAL badfop()
  514. {
  515.     xlfail("bad floating point operation");
  516. }
  517.